; ORIGINAL: 3dt2.1/examples/schemers/castle.scm
;;
;; castle.scm
;;
;; Creates the Castle used for illustration purposes in Chapter 1 of the
;; "Getting Started" book.
;;
;; Edward C. Martin, Schemers Inc.
;; 19 December 1993
;;

;; *** NOTE: To draw the castle in a color other than GREEN, search for
;; three asterisks *** in the code below and make the change suggested.

(provide 'castle)

;; Clears the slate
(part:clear)
(for-each view:delete (env:views))

;; loads some basic coloring and rendering procedures.
(load "rdrpaint.scm")

;; establishes a view for the castle.
;;
(define C-view
  (let ((vw (view:dl 1 1 400 400)))
    (view:set
      (position 200 -400 224) (position -4 8 20) (gvector 0 0 1) vw)
    (view:set-size 132 125 vw)
    (view:set-title "The Castle" vw)
    vw))

;; (make-hole-punch ctr w ht d)
;; returns a solid made from two cylinders and a block that is used to
;; punch "arrow slit" windows out of cylindrical tube castle towers.
;;
;; The arguments are as follows:
;;  ctr  is a position giving the location of the center of mass of one
;;       face of the block in the same plane as the flat bases of the
;;       cylinders
;;  w    specifies the side-to-side width of the window slit
;;  ht   specifies the overall height, including both cylinders and the
;;       block
;;  d    gives the depth of the "hole punch solid"
;;
(define make-hole-punch
  (lambda (ctr w ht d)
    (let ((semi-ht (/ (- ht w) 2))
          (semi-w (/ w 2)))
      (let ((tctr (position:offset ctr (gvector 0 0 semi-ht)))
            (bctr (position:offset ctr (gvector 0 0 (- semi-ht))))
            (tcorner (position:offset ctr (gvector d semi-w semi-ht)))
            (bcorner
              (position:offset ctr (gvector 0 (- semi-w) (- semi-ht)))))
        (solid:unite
          (solid:block bcorner tcorner)
          (solid:cylinder tctr
                          (position:offset tctr (gvector d 0 0))
                          semi-w)
          (solid:cylinder bctr
                          (position:offset bctr (gvector d 0 0))
                          semi-w))))))

;; (make-tower-tube in out h cx w ht)
;; returns a castle tower, that is, a solid formed from a cylindrical tube
;; that has had an "arrow slit" window punched out near the top on one side
;; and a rectangular door way punched out at the bottom on the opposite side.
;; It is created with the center of its base on the x-axis.
;;
;; The arguments are as follows:
;;  in   the inner radius of the tower
;;  out  the outer radius of the tower
;;  h    the height of the tower
;;  cx   the x-coordinate of the center of the tower's base
;;  w    the side-to-side width of both the slit window and the door
;;  ht   the overall height of both the slit window and the door
;;
(define make-tower-tube
  (lambda (in out h cx w ht)
    (solid:subtract
      (solid:cylinder (position cx 0 0)
                      (position cx 0 h)
                      out)
      (solid:cylinder (position cx 0 0)
                      (position cx 0 h)
                      in)
      (make-hole-punch (position cx 0 (- h ht))
                       w ht (* 1.1 out))
      (solid:block (position (- cx (* 1.1 out)) (/ w -2) 0)
                   (position cx (/ w 2) ht)))))

;; (battlement-bites x miny maxy z gap thick
;; returns a list of rectangular blocks that form the gaps of the
;; battlements on one wall (perpendicular to the x-axis).
;;
;; The arguments are as follows:
;;     x  the constant x-coordinate of the inner side of the wall
;;  miny  the minimum y-coordinate of the wall
;;  maxy  the maximum y-coordinate of the wall
;;     z  the z-coordinate of the top of the wall
;;   gap  the width of each battlement (and each gap between battlements)
;; thick  the thickness of the wall
;;
(define battlement-bites
  (lambda (x miny maxy z gap thick)
    (let ((extent (- maxy miny)))
      (let ((n (quotient (quotient (floor extent) gap) 2)))
        (let ((offset (/ (- extent (* (- (* 2 n) 1) gap)) 2))
              (ht (/ gap 2)))
          (letrec ((bite-list
                     (lambda (curry k)
                       (if (> k n)
                           '()
                           (cons
                             (solid:block
                               (position x curry (- z ht))
                               (position (+ x thick) (+ curry gap) z))
                             (bite-list (+ curry (* 2 gap)) (+ k 1)))))))
            (bite-list (+ miny offset) 1)))))))

;; (tower-and-wall in out h cx ht caph gap thick)
;; returns a solid comprising a tower (as described above), a hollowed-out
;; conical cap, and an adjacent wall.
;;
;; The first six arguments have the same meanings as in  make-tower  above.
;; The 7th argument specifies the height of the conical cap, the 8th gives
;; the width of each battlement, and the final argument gives the
;; thickness of the wall.
;; The wall is at 45 degrees to the radius through the tower's central axis
;; and the center of the slit window.
;;
(define tower-and-wall
  (lambda (in out h cx w ht caph gap thick)
    (let ((semi-th (/ thick 2)))
      (solid:unite
        (make-tower-tube in out h cx w ht)
        (entity:transform
          (apply solid:subtract
                 (cons (solid:block (position (- cx semi-th) (- in) 0)
                                    (position (+ cx semi-th)
                                              (- in (* (sqrt 2) cx))
                                              (- h (/ ht 4))))
                       (battlement-bites
                         (- cx semi-th)
                         (- out (* (sqrt 2) cx))
                         (- out) h gap thick)))
          (transform:rotation
            (position cx 0 0) (gvector 0 0 -1) 45))
        (solid:subtract
          (solid:cone (position cx 0 h)
                      (position cx 0 (+ h caph))
                      out 0)
          (solid:cone (position cx 0 h)
                      (position cx 0 (+ h (/ (* in caph) out)))
                      in 0))))))

;; (gateway gcx height thick)
;; returns a gateway made up of a square prism surmounted by a semi-
;; circular prism, both perpendicular to the x-axis.
;;
;; The arguments are as follows:
;;    gcx  the x-coordinate of the center of the gateway
;; height  the overall height of the gateway
;;  thick  the thickness of the gateway
;;
(define gateway
  (lambda (gcx height thick)
    (let* ((width (/ (* height 2) 3))
           (rad (/ width 2))
           (inx (- gcx (/ thick 2)))
           (outx (+ inx thick)))
      (solid:unite
        (solid:block
          (position inx (- rad) 0) (position outx rad width))
        (solid:cylinder
          (position inx 0 width) (position outx 0 width) rad)))))

;; (portcullis pcx height thick)
;; returns a portcullis perpendicular to the x-axis, with square
;; cross-section bars of side  2/3 * thick.
;;
;; The arguments have similar meanings to those of  gateway.
;;
(define portcullis
  (lambda (pcx height thick)
    (let* ((width (/ (* height 2) 3))
           (semi-side (/ thick 3))
           (inx (- pcx semi-side))
           (outx (+ pcx semi-side))
           (ny (quotient (floor (- (/ width semi-side) 2)) 8))
           (nz (quotient (floor (+ (/ height semi-side) 2)) 8)))
      (letrec ((verticals
                 (lambda (curry k)
                   (if (> k ny)
                       '()
                       (cons
                         (solid:block
                           (position inx curry 0)
                           (position outx (+ curry (* 2 semi-side)) height))
                         (verticals (+ curry (* 8 semi-side)) (+ k 1))))))
               (horizontals
                 (lambda (currz t)
                   (if (> t nz)
                       '()
                       (cons
                         (solid:block
                           (position inx (/ width -2) currz)
                           (position outx (/ width 2)
                                     (+ currz (* 2 semi-side))))
                         (horizontals (+ currz (* 8 semi-side)) (+ t 1)))))))
        (apply solid:unite
               (append
                 (verticals (* semi-side (- 3 (* 4 ny))) 1)
                 (horizontals (* 4 semi-side) 1)))))))

;; (plinth cx out thick)
;; returns a square block on which the castle will stand.
;; The arguments have the same meaning as in the procedure  castle  below.
;;
(define plinth
  (lambda (cx out thick)
    (let ((semi-side (/ (+ cx (* 2 out) 25) (sqrt 2))))
      (solid:block
        (position (- semi-side) (- semi-side) (- thick))
        (position semi-side semi-side 0)))))

;; (castle in out h cx w ht caph gap thick)
;; returns a castle made up of four copies of the output from the procedure
;; tower-and-wall,  rotated so as to combine appropriately, with a gateway
;; containing a portcullis in one wall, and standing on a plinth.
;; The arguments have the same meaning as in the procedure  tower-and-wall
;; above.
;;
(define castle
  (lambda (in out h cx w ht caph gap thick)
    (roll:mark-start)
    (let ((old-auto-display (env:auto-display)))
      (env:set-auto-display OFF)
      (let* ((q1 (tower-and-wall in out h cx w ht caph gap thick))
             (q2 (entity:copy q1))
             (q3 (entity:copy q2))
             (q4 (entity:copy q3))
             (rotate-about-z-axis
               (lambda (ent angle)
                 (entity:transform
                   ent
                   (transform:rotation
                     (position 0 0 0) (gvector 0 0 1) angle)))))
        (let ((building
                (solid:unite
                  (solid:subtract
                    (solid:unite
                      q1
                      (rotate-about-z-axis q2 90)
                      (rotate-about-z-axis q3 180)
                      (rotate-about-z-axis q4 270)
                      (rotate-about-z-axis
                        (plinth cx out thick)
                        45))
                    (rotate-about-z-axis
                      (gateway (/ cx (sqrt 2)) (/ (* 2 h) 3) thick) -45))
                  (rotate-about-z-axis
                    (portcullis (/ cx (sqrt 2)) (/ (* 2 h) 3) thick) -45))))
          (entity:facet building)

          ;; *** To change the color in which the castle is drawn,
          ;; *** change the all-caps color variable in the next line
          ;; *** to another of the standard 8 color names given at the
          ;; *** beginning of the file  rdrpaint.scm.

          (entity:paint building GREEN)
          (env:set-auto-display old-auto-display)
          (roll:mark-end)
          building)))))

;; (h r)  and  (k r)
;; return dimensions based on  r  that are important in the specification
;; of the centers of the cannonballs in the triangular pyramid.
;;
(define h
  (lambda (r)
    (* r (sqrt 3))))

(define k
  (lambda (r)
    (/ (* 2 r (sqrt 6)) 3)))

;; (cannonballs r)
;; return ten cannonballs with radius  r  welded together into a triangular
;; pyramid stack.
;;
(define cannonballs
  (lambda (r)
    (let ((S1 (lambda (r)
                (solid:sphere (position 0 (h r) r) r)))
          (S2 (lambda (r)
                (solid:sphere (position (- r) 0 r) r)))
          (S3 (lambda (r)
                (solid:sphere (position r 0 r) r)))
          (S4 (lambda (r)
                (solid:sphere (position (* -2 r) (- (h r)) r) r)))
          (S5 (lambda (r)
                (solid:sphere (position 0 (- (h r)) r) r)))
          (S6 (lambda (r)
                (solid:sphere (position (* 2 r) (- (h r)) r) r)))
          (S7 (lambda (r)
                (solid:sphere (position 0 (/ (h r) 3) (+ (k r) r)) r)))
          (S8 (lambda (r)
                (solid:sphere (position (- r) (/ (* 2 (h r)) -3)
                                        (+ (k r) r))
                              r)))
          (S9 (lambda (r)
                (solid:sphere (position r (/ (* 2 (h r)) -3)
                                        (+ (k r) r))
                              r)))
          (S10 (lambda (r)
                 (solid:sphere (position 0 (/ (h r) -3)
                                         (+ (* 2 (k r)) r))
                               r))))
      (solid:unite
        (S1 r) (S2 r) (S3 r) (S4 r) (S5 r)
        (S6 r) (S7 r) (S8 r) (S9 r) (S10 r)))))

;; returns the particular castle used in Chapter 1.
;;
(define C (castle 7 10 50 50 3 8 10 8 3))

;; returns the stack of cannonballs required for the sample castle, located
;; on the plinth outside the right-hand wall.
;;
(define stack
  (let ((old-auto (env:auto-display)))
    (env:set-auto-display OFF)
    (let ((C (cannonballs 3)))
      (entity:facet C)
      (entity:paint C RED)
      (env:set-auto-display old-auto)
      (entity:transform
        C
        (transform:translation (gvector 34 39 0))))))

;; Render the castle and cannonballs.
;;
(render (list C stack) C-view)

;;
;; end of file  castle.scm
